home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / bytecodes.h < prev    next >
Text File  |  1992-09-14  |  12KB  |  574 lines
  1. /* Contains definitions of all the bytecodes I'll use */
  2.  
  3. #define BC_NOP_CODE        \
  4. /* easy */
  5.  
  6. /* Arg 0: Module, Arg 1: offset */
  7. #define BC_PUSH_GLOBAL_CODE \
  8. {                \
  9.   int i,j;            \
  10.   LispObject tmp;        \
  11.                 \
  12.   read_int_arg(i,pc);        \
  13.   read_int_arg(j,pc);        \
  14.   PUSH_VAL(sp,GLOB_REF(i,j));    \
  15. }
  16.  
  17. #define BC_PUSH_STATIC_CODE \
  18. {                \
  19.   int j;            \
  20.   LispObject tmp;        \
  21.   read_int_arg(j,pc);        \
  22.   PUSH_VAL(sp,GLOB_REF(this_vector,j));    \
  23.   VCHECK(PEEK_VAL(sp));        \
  24. }
  25.  
  26. #define BC_SET_STATIC_CODE     \
  27. {                \
  28.   int j;            \
  29. /**/                \
  30.   read_int_arg(j,pc);        \
  31.   GLOB_REF(this_vector,j)=TOP_VAL(sp);    \
  32. }
  33.  
  34. /* Arg 0: module, Arg 1: offset */
  35. #define BC_SET_GLOBAL_CODE \
  36. {                \
  37.   int i,j;            \
  38.                   \
  39.   read_int_arg(i,pc);        \
  40.   read_int_arg(j,pc);        \
  41.   GLOB_REF(i,j) = TOP_VAL(sp);        \
  42. }
  43.  
  44. #define BC_PUSH_FIXNUM_CODE \
  45. {        \
  46.   int i;    \
  47.   LispObject tmp;    \
  48.   read_int_arg(i,pc);    \
  49.   tmp=allocate_integer(sp+1,i);    \
  50.   PUSH_VAL(sp,tmp);    \
  51. }
  52.  
  53. #define BC_PUSH_SPECIAL_CODE        \
  54. {                    \
  55.    switch (*(pc++))            \
  56.      {                    \
  57.      case 0:                \
  58.        PUSH_VAL(sp,BCnil);        \
  59.        break;                \
  60.                            \
  61.      case 1:                \
  62.        PUSH_VAL(sp,BCtrue);        \
  63.        break;                \
  64.                            \
  65.      default:                \
  66.        fprintf(stderr,"odd special");   \
  67.        PUSH_VAL(sp,BCnil);        \
  68.        break;                \
  69.      }                    \
  70. }
  71.  
  72. /* args: n */
  73. #define BC_PUSH_NTH_CODE     \
  74. {                \
  75.   int i;            \
  76.   LispObject tmp;        \
  77.   read_byte_arg(i,pc);        \
  78. /**/                  \
  79.   tmp=NTH_REF(sp,i);        \
  80.   PUSH_VAL(sp,tmp);        \
  81. }
  82.  
  83. /* Arg 1: n */
  84. #define BC_SET_NTH_CODE        \
  85. {                \
  86.   int i;            \
  87.                 \
  88.   read_byte_arg(i,pc);        \
  89.                 \
  90.   NTH_REF(sp,i)=PEEK_VAL(sp);    \
  91.   POP_VALS(sp,1);        \
  92.   VCHECK(PEEK_VAL(sp));        \
  93. }
  94.  
  95.  
  96. /* Arg1: dist arg2: keep */
  97.  
  98. #define BC_SLIDE_STACK_CODE    \
  99. {                \
  100.   int depth,keep,n,counter;    \
  101.                   \
  102.   read_byte_arg(depth,pc);        \
  103.   read_byte_arg(keep,pc);        \
  104.   sp-= depth;                \
  105.   n=depth-keep;                \
  106.   for (counter=0; counter<keep;        \
  107.        counter++)            \
  108.    {                    \
  109.      sp++;                \
  110.      *sp= *(sp+n);            \
  111.     }                    \
  112. }
  113.  
  114.  
  115. #define BC_SWAP_CODE        \
  116. {                \
  117.   LispObject tmp;        \
  118.                 \
  119.   tmp= *sp;            \
  120.   *sp = *(sp-1);        \
  121.   *(sp-1) = tmp;        \
  122. }
  123.  
  124.  
  125. #define BC_DROP_CODE        \
  126. {                \
  127.   int i;            \
  128.                 \
  129.   read_byte_arg(i,pc)        \
  130.   POP_VALS(sp,i);        \
  131. }
  132.  
  133. /* arg1: depth arg2: dist */
  134. #define BC_ENV_REF_CODE        \
  135. {                \
  136.   int i,j,counter;        \
  137.   LispObject env=PEEK_VAL(sp);    \
  138.                 \
  139.   read_byte_arg(i,pc);        \
  140.   read_byte_arg(j,pc);        \
  141.   ENV_REF(env,env,i,j);        \
  142.   SHOVE_VAL(sp,env);        \
  143.   VCHECK(PEEK_VAL(sp));        \
  144. }
  145.  
  146. /* arg1: depth arg2: dist */
  147. #define BC_SET_ENV_CODE        \
  148. {                \
  149.   int i,j,counter;        \
  150.   LispObject env;        \
  151.   LispObject val;        \
  152.   val=TOP_VAL(sp);        \
  153.   env=PEEK_VAL(sp);        \
  154.                 \
  155.   read_byte_arg(i,pc);        \
  156.   read_byte_arg(j,pc);        \
  157.   SET_ENV_REF(env,i,j,val);    \
  158. }
  159.  
  160. /* Arg1: Depth */
  161. #define BC_POP_ENV_CODE        \
  162. {                \
  163.   int i,counter;        \
  164.   LispObject env=PEEK_VAL(sp);    \
  165.                 \
  166.   read_byte_arg(i,pc);        \
  167.   ENV_NTH(env,i);        \
  168.   SHOVE_VAL(sp,env);        \
  169.   VCHECK(PEEK_VAL(sp));        \
  170. }
  171.  
  172.  
  173. #define BC_MAKE_ENV_CODE    \
  174. {                \
  175.   int i;            \
  176.                 \
  177.   read_byte_arg(i,pc);        \
  178.   MAKE_ENV(sp,i);        \
  179.   VCHECK(PEEK_VAL(sp));        \
  180.   GC_RESTORE_GLOBALS;        \
  181. }
  182.  
  183. /* Object reference */
  184. /* arg: n */
  185. #define BC_VREF_CODE        \
  186. {                \
  187.   LispObject tmp=TOP_VAL(sp);    \
  188. /**/                \
  189.   SHOVE_VAL(sp,vref(PEEK_VAL(sp),    \
  190.             intval(tmp)));    \
  191.   VCHECK(PEEK_VAL(sp));    \
  192. }
  193. #if 0
  194.   if (intval(tmp) > PEEK_VAL(sp)->VECTOR.length)    
  195.     CallError(sp+2,"duff vector-ref",PEEK_VAL(sp),NONCONTINUABLE); 
  196. #endif
  197. /* arg: n */
  198. #define BC_SET_VREF_CODE        \
  199. {                    \
  200.   LispObject val=TOP_VAL(sp);        \
  201.   LispObject loc;            \
  202.   loc=TOP_VAL(sp);              \
  203. /**/                    \
  204.   vref(PEEK_VAL(sp),intval(loc))=val;    \
  205.   SHOVE_VAL(sp,val);            \
  206. }
  207.  
  208.  
  209. #define BC_SLOT_REF_CODE           \
  210. {                    \
  211.   LispObject obj=PEEK_VAL(sp);        \
  212.   int i;                \
  213. /**/                    \
  214.   read_byte_arg(i,pc);            \
  215.   SHOVE_VAL(sp,slotref(obj,i));    \
  216.   VCHECK(PEEK_VAL(sp));        \
  217. }
  218.  
  219. #define BC_SET_SLOT_CODE         \
  220. {                    \
  221.   LispObject val;            \
  222.   LispObject obj;            \
  223.   int i;                \
  224. /**/                    \
  225.   val=TOP_VAL(sp);            \
  226.   obj=PEEK_VAL(sp);            \
  227. /**/                    \
  228.   read_byte_arg(i,pc);            \
  229.   slotref(obj,i)=val;            \
  230.   SHOVE_VAL(sp,val);            \
  231. }
  232.  
  233. #define BC_SET_TYPE_CODE               \
  234. {                           \
  235.   LispObject type;            \
  236.   type=TOP_VAL(sp);            \
  237. /**/                      \
  238.   lval_typeof(PEEK_VAL(sp))=intval(type);    \
  239. }
  240.  
  241. #define BC_BRANCH_CODE        \
  242. {                \
  243.   int i;            \
  244.   bytecode *opc=pc;        \
  245.                   \
  246.   read_int_arg(i,pc);        \
  247.   pc=ADJUST_PC(opc,i);        \
  248. }
  249.  
  250. #define BC_BRANCH_NIL_CODE    \
  251. {                \
  252.   int i;            \
  253.                 \
  254.   if (TOP_VAL(sp)==BCnil)    \
  255.     {                \
  256.       bytecode *opc=pc;        \
  257.       read_int_arg(i,pc);    \
  258.       pc=ADJUST_PC(opc,i);    \
  259.     }                \
  260.   else                \
  261.     skip_int_arg(pc);        \
  262. }
  263.  
  264. /* The tricky ones.... */
  265. /* stack is: fn <lab> a0 a1....an fn */
  266. /* return is: val */
  267.  
  268. #define GENERIC_LOOKUP            \
  269.  
  270. #define BC_APPLY_ANY_CODE    \
  271. {                \
  272.   int nargs,abs_args,real_args;    \
  273.   LispObject fn;        \
  274.   LispObject *arg_start;    \
  275. /**/                \
  276.   read_sign_arg(nargs,pc);    \
  277.   abs_args=nargs<0? -nargs: nargs; \
  278.   fn=TOP_VAL(sp);        \
  279. /**/                \
  280.   switch(typeof(fn))        \
  281.     {                \
  282.     case TYPE_GENERIC:                            \
  283.       {                                \
  284.     LispObject ptr,*walker,fast;                    \
  285.     LispObject meths;                    \
  286.     LispObject *arg_1;                    \
  287.     int count;                        \
  288.                                 \
  289.     arg_1=(sp-nargs)+1;                        \
  290.     fast=(generic_fast_method_cache(fn));         \
  291.     ptr=CAR(fast);                    \
  292.     /* is there a cache ? */                \
  293.     if (ptr!=nil)                        \
  294.       {                            \
  295.         /** Method lookup **/                \
  296.         walker=arg_1;                    \
  297.         count=0;                        \
  298.         while (count<nargs && CAR(ptr)==classof(*(walker)))    \
  299.           {                            \
  300.         ptr=CDR(ptr);                    \
  301.         walker++; count++;                \
  302.           }                            \
  303.                                 \
  304.         if (count==nargs)                    \
  305.           {                            \
  306.         meths=CDR(fast);    \
  307.         goto call_method;                \
  308.           }                            \
  309.         /* then the slow cache */                \
  310.         ptr=generic_slow_method_cache(fn);            \
  311.         walker=arg_1;                    \
  312.         count=0;                        \
  313.                                 \
  314.         while(ptr!=nil && count<nargs)            \
  315.           {                            \
  316.         if (CAR(CAR(ptr))==classof(*(walker)))        \
  317.           {        /* move down 1 */        \
  318.             ptr=CDR(CAR(ptr));                \
  319.             walker++;                    \
  320.             count++;                    \
  321.           }                        \
  322.         else                        \
  323.           ptr=CDR(ptr);                    \
  324.           }                            \
  325.                                 \
  326.         if (count==nargs)                    \
  327.           {                            \
  328.         generic_fast_method_cache(fn)=ptr;        \
  329.         meths=CDR(ptr);                    \
  330.         goto call_method;                \
  331.           }                            \
  332.         /* not in slow cache */                \
  333.       }                            \
  334.     /* no cache */                        \
  335.       {                            \
  336.       LispObject res,args;                    \
  337.       LispObject *stacktop=sp+1,*stackbase=arg_1;        \
  338.       STACK_TMP(fn);                    \
  339.       args=allocate_n_conses(stacktop,nargs);        \
  340.       ptr=args;                        \
  341.       walker=stackbase;                    \
  342.       count=0;                        \
  343.       while (count<nargs)                    \
  344.         {                            \
  345.           CAR(ptr)= *walker;                \
  346.           ptr=CDR(ptr); ++walker; ++count;            \
  347.         }                            \
  348.       UNSTACK_TMP(fn);                    \
  349.         /* Call the methods...*/                \
  350.       SET_STACK(sp,arg_1);                    \
  351.           *sp=fn; *(sp+1)=args;    sp++;                \
  352.           APPLY_BVF(GLOBAL_REF(Generic_Lookup_Fn),2);        \
  353.       break;        /* Wonder where to */        \
  354.       }                            \
  355.       call_method:                        \
  356.     /* method calling code */                \
  357.     BCM_CALL_METHOD_LIST(arg_1,meths,nargs);        \
  358.     }                                \
  359.       break;                    \
  360.     case TYPE_B_FUNCTION:                \
  361.     case TYPE_B_MACRO:                \
  362.       {                        \
  363.     int real_args=intval(bytefunction_nargs(fn));            \
  364.     if (nargs>=0 && real_args<0)        \
  365.       {                    \
  366.         int j=nargs+1;            \
  367.         int k= -real_args;            \
  368.         LispObject *cons_sp;        \
  369.         *(++sp)=BCnil;            \
  370.             cons_sp=sp+2;            \
  371.         /*loop til we have lost enough*/    \
  372.         while (k!=j)            \
  373.           {                    \
  374.         LispObject tmp;            \
  375.         *(sp+1)=fn;            \
  376.         sp--;         \
  377.                 *cons_sp=*sp;                    \
  378.         *(cons_sp+1)=*(sp+1);                \
  379.         tmp=Fn_cons(cons_sp);                \
  380.         *sp=tmp;                     \
  381.         cons_sp--;                    \
  382.         fn=*(sp+2);                    \
  383.         j--;                        \
  384.           }                            \
  385.         GC_RESTORE_GLOBALS;                    \
  386.       }                            \
  387.     APPLY_BVF(fn,nargs);                    \
  388.     }                            \
  389.        break;                            \
  390.     default:                            \
  391.       {                                \
  392.     LispObject res;                        \
  393.     arg_start=sp-abs_args;                    \
  394.     res=module_apply_args(arg_start+1,nargs,fn);        \
  395.     GC_RESTORE_GLOBALS;                    \
  396.     POP_VALS(sp,abs_args);                    \
  397.     pc=SET_PC(this_vector,PEEK_VAL(sp));              \
  398.     POP_VALS(sp,1);                                   \
  399.     *sp=res;                    \
  400.       }                                \
  401.       break;                            \
  402.     }                                \
  403. }
  404.  
  405. #define BC_APPLY_BVF_CODE    \
  406. {                    \
  407.   LispObject fn;            \
  408.   int nargs;                \
  409.   read_byte_arg(nargs,pc);    \
  410. /**/                \
  411.   fn=TOP_VAL(sp);        \
  412.   APPLY_BVF(fn,nargs);        \
  413. }
  414.  
  415.  
  416. #define BC_APPLY_METHODS_CODE    \
  417. {                    \
  418.   LispObject ml;            \
  419.   int args;                \
  420.   LispObject *base;            \
  421.                       \
  422.   read_byte_arg(args,pc);        \
  423.   base=sp-args;                \
  424.                       \
  425.   ml=TOP_VAL(sp);            \
  426.                     \
  427.   BCM_CALL_METHOD_LIST(base,ml,args);    \
  428. }
  429.  
  430. #define BC_PUSH_LABEL_CODE    \
  431. { /* istream should hold an offset */    \
  432.   bytecode *new_pc;                \
  433.   LispObject xx;            \
  434.   int i;                \
  435.   bytecode *opc=pc;            \
  436. /**/                    \
  437.   read_int_arg(i,pc);            \
  438.   new_pc=ADJUST_PC(opc,i);        \
  439.   BC_BUG( if (GLOBAL_REF(BC_Debug)==BCtrue) fprintf(stderr,"Push lab: %x",new_pc));    \
  440.   xx=REIFY_PC(new_pc);            \
  441.   PUSH_VAL(sp,xx);            \
  442. }
  443.  
  444. /* stack is: fn <addr> retval        */
  445. #define BC_RETURN_CODE    /* and back */    \
  446. {                    \
  447.   LispObject tmp=TOP_VAL(sp);        \
  448. /**/                    \
  449.   VCHECK(tmp);                \
  450.   pc=SET_PC(this_vector,PEEK_VAL(sp));    \
  451.   POP_VALS(sp,1);            \
  452.   SHOVE_VAL(sp,tmp);            \
  453. }
  454.  
  455. /** External environment */
  456. #define BC_CONTEXT_CODE    \
  457. {            \
  458.   LispObject tmp;    \
  459.   tmp=allocate_integer(sp+1,this_vector);    \
  460.   PUSH_VAL(sp,tmp);        \
  461. }            \
  462.  
  463. #define BC_EXIT_CODE                 \
  464. {                        \
  465.   BC_BUG( if (GLOBAL_REF(BC_Debug)==BCtrue) fprintf(stderr,"{exiting: %x}",sp));    \
  466.   return (TOP_VAL(sp));                \
  467. }
  468.  
  469. /* allocation */
  470.  
  471. #define BC_CONS_CODE    \
  472. {            \
  473.   LispObject tmp;    \
  474. /**/            \
  475.   tmp=Fn_cons(sp-1);    \
  476.   POP_VALS(sp,1);    \
  477.   SHOVE_VAL(sp,tmp);        \
  478.   GC_RESTORE_GLOBALS;    \
  479. }
  480.  
  481. #define BC_NULLP_CODE    \
  482. {            \
  483.   if (PEEK_VAL(sp)==BCnil)\
  484.     SHOVE_VAL(sp,BCtrue);    \
  485.   else                \
  486.     SHOVE_VAL(sp,BCnil);    \
  487. }
  488.  
  489. #define BC_EQP_CODE    \
  490. {            \
  491.   LispObject tmp;    \
  492. /**/            \
  493.   tmp=TOP_VAL(sp);    \
  494. /**/            \
  495.   if (PEEK_VAL(sp)==tmp) \
  496.     SHOVE_VAL(sp,BCtrue); \
  497.   else             \
  498.     SHOVE_VAL(sp,BCnil); \
  499. }
  500.  
  501. #define BC_ALLOC_CLOSURE_CODE         \
  502. { /* expect <label> <env> on stack, nargs in stream */              \
  503.   LispObject env;                              \
  504.   LispObject rpc;                              \
  505.   LispObject tmp,tmp2;                              \
  506.   bytecode *start;                              \
  507.   int vector;                                  \
  508.   int nargs;                                  \
  509.   /* ought to be a long */                          \
  510.   read_sign_arg(nargs,pc);                          \
  511.                                         \
  512.   tmp=allocate_instance(sp+1,ByteFunction);                  \
  513.   lval_typeof(tmp)=TYPE_B_FUNCTION;                      \
  514.   bytefunction_env(tmp)=TOP_VAL(sp);                      \
  515.                                       \
  516.   /* Tacky... grab the (reified) label and extract into closure */      \
  517.   rpc=TOP_VAL(sp);                              \
  518.   start=SET_PC(vector,rpc);                          \
  519.   PUSH_VAL(sp,tmp);                              \
  520.   tmp2=allocate_integer(sp+1,vector);                       \
  521.   tmp=PEEK_VAL(sp);                              \
  522.   bytefunction_codenum(tmp)=tmp2;                      \
  523.   tmp=allocate_integer(sp+1,nargs);                      \
  524.   bytefunction_nargs(PEEK_VAL(sp))=tmp;                        \
  525.   tmp=allocate_integer(sp+1,start-bytevector_start(vector));          \
  526.   bytefunction_offset(PEEK_VAL(sp))=tmp;                  \
  527.   GC_RESTORE_GLOBALS;                              \
  528. }
  529.  
  530.  
  531.  
  532.  
  533. /* Inserted by other macros */
  534. /* bungs return onto stack */
  535. #define BCM_CALL_METHOD_LIST(base,ml,nargs)    \
  536. {                    \
  537.   LispObject mf;            \
  538.                     \
  539.   mf=method_function(CAR(ml));        \
  540.   switch(typeof(mf))            \
  541.     {                    \
  542.     case TYPE_B_FUNCTION:        \
  543.       /* stuff meths somewhere */    \
  544.       SET_NTH_REF(base,2,ml);        \
  545.       APPLY_BVF(mf,nargs);        \
  546.       break;                \
  547.                     \
  548.     default:                \
  549.       {                    \
  550.     LispObject res;            \
  551.     res = call_method(base,nargs,ml);    \
  552.     GC_RESTORE_GLOBALS;            \
  553.     SET_STACK(sp,base-1);            \
  554.         pc=SET_PC(this_vector,PEEK_VAL(sp));  \
  555.     POP_VALS(sp,1);                   \
  556.     SHOVE_VAL(sp,res);    \
  557.     break;                \
  558.       }                    \
  559.     }                    \
  560. }
  561.  
  562.  
  563.  
  564.  
  565. #define APPLY_BVF(fn,nargs)    \
  566. {                \
  567.   /* Set the return address */  \
  568.   /*SET_NTH_REF(sp,nargs+1,    \
  569.           REIFY_PC(pc));*/    \
  570.   pc=BF2PC(fn);            \
  571.   /* Push environment */    \
  572.   PUSH_VAL(sp,bytefunction_env(fn));    \
  573. }
  574.